package Object::Tie;

use strict;
use Carp qw(croak);
use constant DEBUG => 0;

our $PUB = 1;       # public
our $PRI = 2;       # private
our $INH = 4;       # inherited
our $PRO = 8;       # protected

my %map = (
	$PUB => 'public',
	$PRI => 'private',
	$PRO => 'protected',
);

our $id;
local *id = \$Object::__IDENTITY_FIELD;

sub TIEHASH {
	my ($pkg,$cls,$pub,$pri,$pro) = @_;
	#warn "Use tied object [ @$pub ][ @$priv ][ @$prot ]\n";
	my $have = 0;
	$have |= $PUB if @$pub;
	$have |= $PRI if @$pri;
	$have |= $PRO if @$pro;
	return bless {
		o => {},
		k => [],
		have => $have,
# 		publ => $pub,
# 		priv => $pri,
# 		prot => $pro,
		f  => {
			(map { $_ => $PUB } @$pub),
			(map { $_ => $PRI } @$pri),
			(map { $_ => $PRO } @$pro),
		},
		#f => { map { $_ => 1 } @$pub,@$priv,@$prot }
		class => $cls,
	},$pkg;
}

sub check {
	my ($self,$f) = @_;
	my $clr = caller(1);
	return if $id and $f eq $id;
	return if $clr eq 'Object'
#	       or $clr eq 'Object::_'
	       or $clr eq 'Data::Dumper';
	my $ft = $self->{f}->{$f};
	#warn " $clr isa $self->{class}\n";
	croak "Class $self->{class} have no field $f" unless $ft;
	croak "No access to $self->{class}( <$map{$ft}>$f ) from $clr"
		if ( $ft & ( $PRI ) and $self->{class} ne $clr )
		or ( $ft & ( $PRI | $PRO ) and ! ( eval{ $clr->isa( $self->{class} ) } or eval{ $self->{class}->isa( $clr ) } ) );
}
sub check_clear {
	my ($self) = @_;
	my $clr = caller(1);
	return if $clr eq 'Object';
	croak "No access to $self->{class}->CLEAR from $clr"
		if ( $self->{have} & $PRI and $self->{class} ne $clr )
		or ( ( $self->{have} & $PRI or $self->{have} & $PRO ) and ! eval{ $clr->isa( $self->{class} ) } )
}

sub FETCH {
	&check;
	warn "fetch\n" if DEBUG;
	$_[0]->{o}->{$_[1]};
}
sub STORE {
	&check;
	warn "store\n" if DEBUG;
	$_[0]->{o}->{$_[1]} = $_[2];
}
sub DELETE {
	&check;
	warn "delete\n" if DEBUG;
	delete $_[0]->{o}->{$_[1]};
}
sub CLEAR {
	&check_clear;
	warn "clear\n" if DEBUG;
	%{$_[0]->{o}} = ( $id => $_[0]->{o}->{$id} );
}
sub EXISTS {
	warn "exists\n" if DEBUG;
	return unless $_[0]->{f}->{$_[1]};
	exists $_[0]->{o}->{$_[1]};
}
sub FIRSTKEY {
	warn "firstkey\n" if DEBUG;
	$_[0]->{k} = [ keys %{$_[0]->{o}} ];
	shift @{$_[0]->{k}};
}
sub NEXTKEY {
	warn "nextkey\n" if DEBUG;
	shift @{$_[0]->{k}};
}
sub SCALAR {
	warn "scalar\n" if DEBUG;
	scalar(%{$_[0]->{o}})
}

1;

__END__
sub FETCH {
	warn "fetch\n" if DEBUG;
	croak "No such field $_[1]" unless $_[0]->{f}->{$_[1]};
	$_[0]->{o}->{$_[1]};
}
sub STORE {
	warn "store\n" if DEBUG;
	croak "No such field $_[1]" unless $_[0]->{f}->{$_[1]};
	$_[0]->{o}->{$_[1]} = $_[2];
}
sub DELETE {
	warn "delete\n" if DEBUG;
	croak "No such field $_[1]" unless $_[0]->{f}->{$_[1]};
	delete $_[0]->{o}->{$_[1]};
}
sub CLEAR {
	warn "clear\n" if DEBUG;
	%{$_[0]->{o}} = ();
}
sub EXISTS {
	warn "exists\n" if DEBUG;
	return unless $_[0]->{f}->{$_[1]};
	exists $_[0]->{o}->{$_[1]};
}
sub FIRSTKEY {
	warn "firstkey\n" if DEBUG;
	$_[0]->{k} = [ keys %{$_[0]->{o}} ];
	shift @{$_[0]->{k}};
}
sub NEXTKEY {
	warn "nextkey\n" if DEBUG;
	shift @{$_[0]->{k}};
}
sub SCALAR {
	warn "scalar\n" if DEBUG;
	scalar(%{$_[0]->{o}})
}

#sub DESTROY { warn "destroy\n" if DEBUG; 
#sub UNTIE {}

1;